home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / primops / carcdr.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  2.9 KB  |  77 lines
  1. (herald carcdr (env tsys (t3_primops aliases) (t3_primops open)))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; car/cdr chains
  27.  
  28. (define-local-syntax (define-carcdr name)
  29.   (let* ((x (symbol->string name))
  30.          (ads (string-slice x 1 (- (string-length x) 2)))
  31.          (sym (generate-symbol 'carcdr))
  32.          (val (generate-symbol 'val))
  33.          (stuff (do ((i (- (string-length ads) 1) (- i 1))
  34.                      (stuff sym (list (xcase (char-upcase (nthchar ads i))
  35.                                         ((#\A) 'CAR)
  36.                                         ((#\D) 'CDR))
  37.                                       stuff)))
  38.                     ((< i 0) stuff))))
  39.     `(block
  40.       (define-constant ,name
  41.         (object (lambda (,sym) ,stuff)
  42.           ((setter self)
  43.            (lambda (,sym ,val)
  44.              (set ,stuff ,val)))))
  45.       (declare type-safe-closed-form ,name))))
  46.  
  47. (define-carcdr caar)     
  48. (define-carcdr cadr)
  49. (define-carcdr cdar)
  50. (define-carcdr cddr)
  51.  
  52. (define-carcdr caaar)
  53. (define-carcdr caadr)
  54. (define-carcdr cadar)
  55. (define-carcdr caddr)
  56. (define-carcdr cdaar)
  57. (define-carcdr cdadr)
  58. (define-carcdr cddar)
  59. (define-carcdr cdddr)
  60.  
  61. (define-carcdr caaaar)
  62. (define-carcdr caaadr)
  63. (define-carcdr caadar)
  64. (define-carcdr caaddr)
  65. (define-carcdr cadaar)
  66. (define-carcdr cadadr)
  67. (define-carcdr caddar)
  68. (define-carcdr cadddr)
  69. (define-carcdr cdaaar)
  70. (define-carcdr cdaadr)
  71. (define-carcdr cdadar)
  72. (define-carcdr cdaddr)
  73. (define-carcdr cddaar)
  74. (define-carcdr cddadr)
  75. (define-carcdr cdddar)
  76. (define-carcdr cddddr)
  77.